; $Id: coloration.lsp,v 1.1.1.1 2002/05/17 20:57:41 uluru Exp $
; by Chad Petty 

; This code is based on the bitmap-edit-proto class in
; Luke Tierney's _Lisp-Stat_, 1990 (section 8.6, p. 257)
;
;
; Given a 2-D matrix (an "image"), this class will draw it
; on the screen, using blue for positive values and red for
; negative, as shown:
;
; matrix      drawing
; values      color
; -------     -------
; high pos:   dark blue
; low pos:    light blue
; 0:          white
; low neg:    light red
; high pos:   dark red
;
; The matrix is normalized by dividing through by the highest positive
; value; this puts all positive values in the range [0,1], as this is
; the range of intensity values that lisp-stat accepts.
;
; TO DO: somehow the negative values need to be handled better. For example,
; if the max negative value is of greater magnitude than the max positive
; value, the normalized max negative value will be greater than 1


(defproto image-disp-proto
  '(im h v) nil graph-window-proto)

(defmeth image-disp-proto :isnew (imin)

  ; Normalize input matrix by max value (puts positive #s in [0,1]
  ; to create "image"

  ; TODO: put all #s in [-1,1] (how?)

  (setf (slot-value 'im) (/ imin (max imin)))

   ; im must be set before calling call-next-method, otherwise 
   ; there are errors because im is null

  (send self :use-color t)
  (call-next-method) 
  )

(defmeth image-disp-proto :im (&optional (val nil set))
  (if set 
      (setf (slot-value 'im) val)
    )
  (slot-value 'im)
  )

(defmeth image-disp-proto :h () (slot-value 'h))

(defmeth image-disp-proto :v () (slot-value 'v))

(defmeth image-disp-proto :resize ()
  (let (
	(m (array-dimension (send self :im) 0))
        (n (array-dimension (send self :im) 1))
        (height (send self :canvas-height))        
        (width (send self :canvas-width))
	)
    (setf (slot-value 'v)
          (coerce (floor (* (iseq 0 m) (/ height m)))
                  'vector))
    (setf (slot-value 'h)
          (coerce (floor (* (iseq 0 n) (/ width n)))
                  'vector))))

(defmeth image-disp-proto :draw-pixel (i j)
  (let* (
	 (b (send self :im))
         (v (send self :v))
         (h (send self :h))
         (left (aref h j))
         (right (aref h (+ j 1)))
         (top (aref v i))
         (bottom (aref v (+ i 1)))
	 (pixval (aref b i j))
	 (pix2 (- 1 (abs pixval)))
	 )
    ; give negative values a shade of red,
    ; positive values a shade of blue.
    ; assumes all values are in [-1,1]

    (if (> pixval 0) (make-color 'g pix2 pix2 1)
      (make-color 'g 1 pix2 pix2)
      )
    (send self :draw-color 'g)
    (send self :paint-rect left top (- right left) (- bottom top))
    )
)

(defmeth image-disp-proto :redraw ()
  (let* (
	 (b (send self :im))
         (m (array-dimension b 0))
         (n (array-dimension b 1))
	 (width (send self :canvas-width))
         (height (send self :canvas-height)))
    (send self :start-buffering)
    (send self :erase-rect 0 0 width height)
    (dotimes (i m)
	     (dotimes (j n)
		      (send self :draw-pixel i j)))
    (send self :buffer-to-screen)
    )
  )

(defmeth image-disp-proto :do-click (x y m1 m2)
  (send self :set-pixel x y))

(defmeth image-disp-proto :set-pixel (x y)
    (let* ((b (send self :im))
           (m (array-dimension b 0))
           (n (array-dimension b 1))
           (w (send self :canvas-width))
           (h (send self :canvas-height))
           (i (min (floor (* y (/ m h))) (- m 1)))
           (j (min (floor (* x (/ n w))) (- n 1)))
           )
      (send self :do-rect i j)))

(defmeth image-disp-proto :do-rect (i j)
  (print (list i j)))

; call this function to display a matrix:

(defun newdisp (im)
  (let (
	(w (send image-disp-proto :new im))
	)
    (send w :use-color t)
    w)
)


; some sample images:

#|
(setf crosshair '#2a((0 1 0) (1 .5 1) (0 1 0)))

(setf bigcrosshair '#2a(
			(0  0  1  0  0)
			(0  0 .8  0  0)
			(1 .8 .6 .8  1)
			(0  0 .8  0  0)
			(0  0  1  0  0)
			))

(setf letterx '#2a(
			(1  0  0  0 1)
			(0 .7  0 .7 0)
			(0  0 .5  0 0)
			(0 .5  0 .7 0)
			(1  0  0  0 1)
			))

(setf  thing1 '#2a(
			(.9  1 .8 .6 .4)
			(.8  0  0  0 .2)
			(.7  0  1  0 .1 )
			(.6  0  0  0  0)
			(.5 .4 .3 .2 .1)
			))

; ramp 1: 0 to 1

(setf ramp1       '#2a(
			(0 .2 .4 .6 .8 1)
			(0 .2 .4 .6 .8 1)
			(0 .2 .4 .6 .8 1)
			(0 .2 .4 .6 .8 1)
			(0 .2 .4 .6 .8 1)
			))


; ramp2: -1 to 1

(setf ramp2       '#2a(
		       (-1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1)
		       (-1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1)
		       (-1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1)
		       (-1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1)
		       (-1 -.8 -.6 -.4 -.2 0 .2 .4 .6 .8 1)
		       ))


; ramp3: 0 to n (shows normalization)

(setf ramp3       '#2a(
			(0 1 2 3 4 5 6 7 8 9 10)
			(0 1 2 3 4 5 6 7 8 9 10)
			(0 1 2 3 4 5 6 7 8 9 10)
			(0 1 2 3 4 5 6 7 8 9 10)
			(0 1 2 3 4 5 6 7 8 9 10)
			))

(setf ramp4 '#2a(
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
		 (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31)
))

(setf ramp5 (matrix '(10 101) (dotimes (i 10) (* (/ i 10) (- (iseq 101) 50)))))

(setf ramp6 (matmult (diagonal (/ (iseq 101) 101))
                       (matrix '(101 101) (repeat (- (iseq 101) 50) 101))))

(setf blank       '#2a(
			(0 0 0 0 0)
			(0 0 0 0 0)
			(0 0 0 0 0)
			(0 0 0 0 0)
			(0 0 0 0 0)
			))

|#